perm filename FEYN[901,BGB] blob
sn#129613 filedate 1974-11-12 generic text, type T, neo UTF8
DEFPROP WWW
(NIL PFEY
DFEY
FEYNMAN
OVERLAP
EQVAL
PHUNT
SETLEVEL
OUTPART
TAGEL
TORG
TORG2
ARROW
FERMI1
BOSE1
BOSE2
FERMI2
FERMI3
ZEG
JIGJAG
JIGJAGZIGZAG
NSET
TFSET
NILVAL
FUSE
IOBOTH
DELETE
INSERT
UNIQUE
UNBUCK
SUBSET
INTERSECTION
PEN
ORG
SIZORG
SIZ
KING
GETNEAR
PNSET
XPLY
ALIKE
SETN
XSET
YSET
YSET2
OAOOP
MOVE
YMINAX
YMISS
LSP
MIDIT
DIT
SOF
EOF
POT
YMAX
XMAX
YMIN
F1
F2
NK
NP
NODE
N0
N1
N2
N3
N4
N5
N6
N7
N8
N9
VADD
VSUB
VSUBSIZ
LXY
SLOPE
MIDPOINT
METRIC
SQUARE
INCREM
CARLAST
ALSH
ADJUST
ROTATE
ROOT
NEWTON
ZIGZAG
SQUIG
TESTS
TP1
TP2
TP3
TP4
TP5
TP6
TP7
TP8
TP9
TP10
TP11
TP12
TP13
TP14
TP15
TP16
TP17
TP18
TP19
TP20
TP20
TP22
OFF)
VALUE)
(DEFPROP PFEY
(LAMBDA(Z)
(PROG (IPL OPL MPL EPL INL ONL MNL ENL YMAX YMIN XMAX)
(SETQ YMAX (SETQ YMIN (SETQ XMAX 0)))
(FEYNMAN Z)
(MAPC (FUNCTION ADJUST) ENL)
(OVERLAP EPL)
(LSP (LIST 0 (TIMES 300 (MINUS YMIN))))
(SETQ ORG (QUOTE (0 . 0)))
(OUTPART (FUNCTION LSP) EPL)
(LSP (LIST (MINUS (CAR (SIZORG))) (PLUS (TIMES 300 YMAX) (MINUS (CDR (SIZORG))) 220)))))
EXPR)
(DEFPROP FEYNMAN
(LAMBDA(Z)
(PROG (NOL)
(CSYM G0000)
(MAPC (FUNCTION NILVAL) (APPEND (CAAR (FUSE Z)) (CDAR (FUSE Z))))
(SETQ MNL (NSET Z))
(SETQ EPL (IOBOTH (FUSE Z)))
(SETQ IPL (CAAR EPL))
(SETQ OPL (CDAR EPL))
(SETQ MPL (CDR EPL))
(SETQ EPL (APPEND IPL OPL MPL))
(SETQ INL (NSET (MAPCAR (FUNCTION (LAMBDA (Z) (LIST NIL Z))) IPL)))
(SETQ ONL (NSET (MAPCAR (FUNCTION (LAMBDA (Z) (LIST (LIST Z)))) OPL)))
(SETQ ENL (APPEND INL MNL ONL))
(MAPC (FUNCTION KING) ENL)
(MAPC (FUNCTION PNSET) ENL)
(XPLY 0 INL NIL)
(SETQ NOL ENL)
YLOOP
(YSET (CAR NOL) YMIN)
(SETQ NOL (YMISS ENL))
(YMINAX (SUBSET ENL NOL))
(COND ((NOT (NULL NOL)) (GO YLOOP)))
(XSET ONL XMAX)
(RETURN NIL)))
EXPR)
(DEFPROP OVERLAP
(LAMBDA(Z)
(COND ((NULL Z) NIL)
((AND (NOT (MEMBER (EVAL (CAR Z)) (MAPCAR (FUNCTION EVAL) (CDR Z))))
(NOT (MEMBER (CONS (CDR (EVAL (CAR Z))) (CAR (EVAL (CAR Z)))) (MAPCAR (FUNCTION EVAL) (CDR Z)))))
(PROG2 (SET (CAR Z) (CONS (EVAL (CAR Z)) 0)) (OVERLAP (CDR Z))))
(T
(PROG (IDPL)
(SETQ IDPL (EQVAL (EVAL (CAR Z)) Z))
(SETLEVEL 0 (PHUNT IDPL IDPL))
(OVERLAP (SUBSET Z IDPL))))))
EXPR)
(DEFPROP EQVAL
(LAMBDA(A Z)
(COND ((NULL Z) NIL)
((OR (EQUAL A (CONS (CDR (EVAL (CAR Z))) (CAR (EVAL (CAR Z))))) (EQUAL A (EVAL (CAR Z))))
(CONS (CAR Z) (EQVAL A (CDR Z))))
(T (EQVAL A (CDR Z)))))
EXPR)
(DEFPROP PHUNT
(LAMBDA(Z1 Z2)
(COND ((NULL Z2) Z1)
((EQ (QUOTE P) (CAR (EXPLODE (CAR Z2)))) (CONS (CAR Z2) (DELETE (CAR Z2) Z1)))
(T (PHUNT Z1 (CDR Z2)))))
EXPR)
(DEFPROP SETLEVEL
(LAMBDA(N Z)
(COND ((NULL Z) NIL)
(T
(PROG2 (SET (CAR Z) (CONS (EVAL (CAR Z)) N))
(SETLEVEL (COND ((ZEROP N) 1) ((MINUSP N) (MINUS (SUB1 N))) (T (MINUS N))) (CDR Z))))))
EXPR)
(DEFPROP OUTPART
(LAMBDA(LS Z)
(COND ((NULL Z) NIL)
(T
(PROG (PPP1 PPP2 LEVEL MIDP CC SS LL L2 KIND)
(SETQ LEVEL (CDR (EVAL (CAR Z))))
(SETQ PPP1 (EVAL (CAAR (EVAL (CAR Z)))))
(SETQ PPP2 (EVAL (CDAR (EVAL (CAR Z)))))
(SETQ KIND (EQ (QUOTE P) (CAR (EXPLODE (CAR Z)))))
(COND
((EQUAL PPP1 PPP2)
(PROG2 (SETQ LEVEL 1)
(COND (KIND (FERMI3 (FUNCTION JIGJAG))) (T (FERMI3 (FUNCTION JIGJAGZIGZAG))))
(RETURN (OUTPART LS (CDR Z))))))
(SETQ MIDP (MIDPOINT PPP1 PPP2))
(LS (LXY (VSUB PPP1 (SIZORG))))
(SETQ L2 (METRIC PPP1 PPP2))
(SETQ LL (ROOT L2))
(SETQ SS (QUOTIENT (DIFFERENCE (CDR PPP2) (CDR PPP1)) LL))
(SETQ CC (QUOTIENT (DIFFERENCE (CAR PPP2) (CAR PPP1)) LL))
(COND ((GET (CAR Z) (QUOTE NFROM)) (MAPC LS NODE)))
(COND ((AND (ZEROP LEVEL) KIND) (FERMI1)) ((ZEROP LEVEL) (BOSE1)) (KIND (FERMI2)) (T (BOSE2)))
(COND ((GET (CAR Z) (QUOTE NTO)) (MAPC LS NODE)))
(OUTPART LS (CDR Z))))))
EXPR)
(DEFPROP TAGEL
(LAMBDA(S C LS CHARS)
(LS
(LXY
(VSUBSIZ ORG
(PROG2 (LS (LXY (VADD (ROTATE (TORG) S C) (TORG2))))
(CARLAST
(MAPCAR (FUNCTION
(LAMBDA (Z) (CARLAST (MAPCAR LS (EVAL (INTERN (MAKNAM (LIST (QUOTE N) Z))))))))
CHARS)))))))
EXPR)
(DEFPROP TORG
(LAMBDA NIL
(CONS
(COND
((OR (MINUSP C) (AND (OR (GREATERP C S) (EQ C S)) (GREATERP S (MINUS C))) (AND (ZEROP C) (MINUSP S))) -6)
(T 6))
(COND
((OR (AND (MINUSP S) (GREATERP C S)) (AND (NOT (MINUSP S)) (GREATERP (MINUS C) S)) (ZEROP S)) 11)
(T -11))))
EXPR)
(DEFPROP TORG2
(LAMBDA NIL
(CONS
(COND
((OR (AND (GREATERP S C) (GREATERP (MINUS C) S)) (AND (EQUAL S C) (MINUSP S))) (TIMES -14 (LENGTH CHARS)))
(T 0))
(COND
((OR (AND (GREATERP C 0) (GREATERP S 0))
(AND (GREATERP C S) (MINUSP C))
(AND (GREATERP (MINUS C) S) (NOT (MINUSP S)))
(ZEROP C))
-14)
(T 0))))
EXPR)
(DEFPROP ARROW
(LAMBDA(S C LS)
(PROG (PSORG)
(SETQ PSORG ORG)
(LS (ROTATE (QUOTE (-25 . 25)) S C))
(LS (ROTATE (QUOTE (17 . -25)) S C))
(LS (ROTATE (QUOTE (-17 . -25)) S C))
(LS
(CONS (QUOTIENT (DIFFERENCE (CAR PSORG) (CAR ORG)) SIZ)
(QUOTIENT (DIFFERENCE (CDR PSORG) (CDR ORG)) SIZ)))))
EXPR)
(DEFPROP FERMI1
(LAMBDA NIL
(PROG NIL (LS (VSUB MIDP PPP1)) (ARROW SS CC LS) (TAGEL SS CC LS (EXPLODE (CAR Z))) (LS (VSUB PPP2 MIDP))))
EXPR)
(DEFPROP BOSE1
(LAMBDA NIL
(PROG (PHASE ACTEND)
(SETQ PHASE 0)
(SETQ ACTEND (QUOTE (0 . 0)))
(SQUIG PPP1 MIDP LS)
(ZEG)
(ARROW SS CC LS)
(TAGEL SS CC LS (EXPLODE (CAR Z)))
(SQUIG MIDP PPP2 LS)
(ZEG)))
EXPR)
(DEFPROP BOSE2
(LAMBDA NIL
(PROG (PSORG LLX PHASE ACTEND)
(SETQ PSORG (SETQ ACTEND (QUOTE (0 . 0))))
(SETQ PHASE 0)
(SETQ LLX (QUOTIENT (ROOT (METRIC PPP2 PPP1)) 8.0))
(JIGJAGZIGZAG 1 (QUOTE (36 52 60 60)))
(ZEG)
(ARROW SS CC LS)
(TAGEL SS CC LS (EXPLODE (CAR Z)))
(JIGJAGZIGZAG 5 (QUOTE (60 52 36 0)))
(ZEG)))
EXPR)
(DEFPROP FERMI2
(LAMBDA NIL
(PROG (PSORG LLX)
(SETQ PSORG (QUOTE (0 . 0)))
(SETQ LLX (QUOTIENT (ROOT (METRIC PPP2 PPP1)) 8.0))
(JIGJAG 1 (QUOTE (36 52 60 60)))
(ARROW SS CC LS)
(TAGEL SS CC LS (EXPLODE (CAR Z)))
(JIGJAG 5 (QUOTE (60 52 36)))
(LS (VSUB PPP2 (SIZORG)))))
EXPR)
(DEFPROP FERMI3
(LAMBDA(JIGGLE)
(PROG (PSORG LLX PHASE ACTEND)
(COND ((OR (GET (CAR Z) (QUOTE NTO)) (GET (CAR Z) (QUOTE NFROM))) (MAPC LS NODE)))
(SETQ PSORG (SETQ ACTEND (QUOTE (0 . 0))))
(SETQ PHASE 0)
(SETQ LLX (TIMES SIZ -30))
(SETQ SS 0.0)
(SETQ CC 1.0)
(JIGGLE 1 (QUOTE (11 36)))
(SETQ LLX (MINUS LLX))
(JIGGLE -1 (QUOTE (60 60)))
(ARROW SS CC LS)
(TAGEL SS CC LS (EXPLODE (CAR Z)))
(JIGGLE 0 (QUOTE (60 60 36)))
(SETQ LLX (MINUS LLX))
(JIGGLE -1 (QUOTE (11)))
(JIGGLE 0 (QUOTE (0)))))
EXPR)
(DEFPROP ZEG
(LAMBDA NIL (PROG2 (LS (CONS (MINUS (CAR ACTEND)) (MINUS (CDR ACTEND)))) (SETQ ACTEND (QUOTE (0 . 0)))))
EXPR)
(DEFPROP JIGJAG
(LAMBDA(N Z)
(COND ((NULL Z) NIL)
(T
(PROG (PTEMP)
(SETQ PTEMP (ROTATE (CONS (TIMES N LLX) (TIMES LEVEL (CAR Z))) SS CC))
(LS (VSUB PTEMP PSORG))
(SETQ PSORG PTEMP)
(JIGJAG (ADD1 N) (CDR Z))))))
EXPR)
(DEFPROP JIGJAGZIGZAG
(LAMBDA(N Z)
(COND ((NULL Z) NIL)
(T
(PROG (PTEMP)
(SETQ PTEMP (ROTATE (CONS (TIMES N LLX) (TIMES LEVEL (CAR Z))) SS CC))
(SQUIG PSORG PTEMP LS)
(SETQ PSORG PTEMP)
(JIGJAGZIGZAG (ADD1 N) (CDR Z))))))
EXPR)
(DEFPROP NSET
(LAMBDA(Z)
(COND ((NULL Z) NIL)
(T
(CONS (PROG (TEMP)
(SET (SETQ TEMP (INTERN (GENSYM))) (CAR Z))
(TFSET (CAAR Z) (FUNCTION CONS))
(TFSET (CDAR Z) (FUNCTION XCONS))
(RETURN TEMP))
(NSET (CDR Z))))))
EXPR)
(DEFPROP TFSET
(LAMBDA(Z FCONS)
(MAPC (FUNCTION
(LAMBDA(X)
(SET X
(COND ((NULL (EVAL X)) (FCONS NIL TEMP))
(T (FCONS (CAR (FCONS (CAR (EVAL X)) (CDR (EVAL X)))) TEMP))))))
Z))
EXPR)
(DEFPROP NILVAL
(LAMBDA (Z) (SET Z NIL))
EXPR)
(DEFPROP FUSE
(LAMBDA(Z)
(COND ((NULL Z) NIL)
((NULL (CDR Z)) Z)
(T (FUSE (CONS (CONS (APPEND (CAAR Z) (CAADR Z)) (APPEND (CDAR Z) (CDADR Z))) (CDDR Z))))))
EXPR)
(DEFPROP IOBOTH
(LAMBDA(Z)
(COND ((NULL (CAAR Z)) Z)
((NULL (CDAR Z)) Z)
((MEMBER (CAAAR Z) (CDAR Z))
(IOBOTH
(CONS (CONS (DELETE (CAAAR Z) (CDAAR Z)) (DELETE (CAAAR Z) (CDAR Z))) (CONS (CAAAR Z) (CDR Z)))))
(T (INSERT (CAAAR Z) (IOBOTH (CONS (CONS (DELETE (CAAAR Z) (CDAAR Z)) (CDAR Z)) (CDR Z)))))))
EXPR)
(DEFPROP DELETE
(LAMBDA(A Z)
(COND ((NULL Z) NIL) (T (APPEND (COND ((EQ A (CAR Z)) NIL) (T (NCONS (CAR Z)))) (DELETE A (CDR Z))))))
EXPR)
(DEFPROP INSERT
(LAMBDA (A Z) (CONS (CONS (CONS A (CAAR Z)) (CDAR Z)) (CDR Z)))
EXPR)
(DEFPROP UNIQUE
(LAMBDA (Z) (COND ((NULL Z) NIL) (T (CONS (CAR Z) (DELETE (CAR Z) (UNIQUE (CDR Z)))))))
EXPR)
(DEFPROP UNBUCK
(LAMBDA (Z) (COND ((NULL Z) NIL) (T (APPEND (CAR Z) (UNBUCK (CDR Z))))))
EXPR)
(DEFPROP SUBSET
(LAMBDA (A B) (COND ((NULL B) A) (T (SUBSET (DELETE (CAR B) A) (CDR B)))))
EXPR)
(DEFPROP INTERSECTION
(LAMBDA(A B)
(COND ((OR (NULL A) (NULL B)) NIL)
(T (APPEND (COND ((MEMQ (CAR A) B) (NCONS (CAR A))) (T NIL)) (INTERSECTION (CDR A) B)))))
EXPR)
(DEFPROP PEN
(NIL)
VALUE)
(DEFPROP ORG
(NIL 0 . 220)
VALUE)
(DEFPROP SIZORG
(LAMBDA NIL (CONS (QUOTIENT (CAR ORG) SIZ) (QUOTIENT (CDR ORG) SIZ)))
EXPR)
(DEFPROP SIZ
(NIL . 1)
VALUE)
(DEFPROP KING
(LAMBDA(Z)
(PUTPROP Z
(UNIQUE
(APPEND (MAPCAR (FUNCTION CAR) (MAPCAR (FUNCTION EVAL) (CAR (EVAL Z))))
(MAPCAR (FUNCTION CDR) (MAPCAR (FUNCTION EVAL) (CDR (EVAL Z))))))
(QUOTE NEAR)))
EXPR)
(DEFPROP GETNEAR
(LAMBDA (Z) (GET Z (QUOTE NEAR)))
EXPR)
(DEFPROP PNSET
(LAMBDA(Z)
(COND ((NULL (CAR (EVAL Z)))
(COND ((NULL (CDR (EVAL Z))) NIL) (T (PUTPROP (CADR (EVAL Z)) T (QUOTE NFROM)))))
(T (PUTPROP (CAAR (EVAL Z)) T (QUOTE NTO)))))
EXPR)
(DEFPROP XPLY
(LAMBDA(N Z AC)
(COND ((ALIKE AC ENL) NIL)
((NULL Z) (XPLY 0 (NCONS (CAR (SUBSET ENL AC))) AC))
(T
(PROG2 (SETQ XMAX (COND ((GREATERP (SETQ NNN N) XMAX) N) (T XMAX)))
(MAPC (FUNCTION SETN) Z)
(XPLY (ADD1 N)
(SUBSET (UNIQUE (UNBUCK (MAPCAR (FUNCTION GETNEAR) Z))) (APPEND AC Z))
(APPEND AC Z))))))
EXPR)
(DEFPROP ALIKE
(LAMBDA(A B)
(COND ((NULL A) (COND ((NULL B) T) (T NIL))) ((NULL B) NIL) (T (ALIKE (CDR A) (DELETE (CAR A) B)))))
EXPR)
(DEFPROP SETN
(LAMBDA (Z) (SET Z NNN))
EXPR)
(DEFPROP XSET
(LAMBDA (Z N) (COND ((NULL Z) NIL) (T (PROG2 (SET (CAR Z) (CONS N (CDR (EVAL (CAR Z))))) (XSET (CDR Z) N)))))
EXPR)
(DEFPROP YSET
(LAMBDA(NOD Y)
(PROG (TEMP)
L1 (SETQ TEMP (CONS (EVAL NOD) Y))
(COND ((OAOOP TEMP ENL) (GO L2)))
(SETQ TEMP (CONS (EVAL NOD) (SUB1 Y)))
(COND ((OAOOP TEMP ENL) (GO L2)))
(SETQ TEMP (CONS (EVAL NOD) (ADD1 Y)))
(COND ((OAOOP TEMP ENL) (GO L2)))
(MOVE ENL Y)
(GO L1)
L2 (SET NOD TEMP)
(YSET2 (GETNEAR NOD) NOD)
(RETURN NIL)))
EXPR)
(DEFPROP YSET2
(LAMBDA(Z NOD)
(COND ((NULL Z) NIL)
(T
(PROG (TEM)
(COND ((NOT (NUMBERP (SETQ TEM (EVAL (CAR Z))))) (GO LL)))
(COND
((EQUAL TEM (CAR (EVAL NOD)))
(COND
((AND (NOT (OAOOP (CONS TEM (SUB1 (CDR (EVAL NOD)))) ENL))
(OAOOP (CONS TEM (ADD1 (CDR (EVAL NOD)))) ENL))
(YSET (CAR Z) (ADD1 (CDR (EVAL NOD)))))
(T (YSET (CAR Z) (SUB1 (CDR (EVAL NOD)))))))
(T (YSET (CAR Z) (CDR (EVAL NOD)))))
LL (YSET2 (CDR Z) NOD)
(RETURN NIL)))))
EXPR)
(DEFPROP OAOOP
(LAMBDA (N Z) (COND ((NULL Z) T) ((EQUAL N (EVAL (CAR Z))) NIL) (T (OAOOP N (CDR Z)))))
EXPR)
(DEFPROP MOVE
(LAMBDA(Z Y)
(COND ((NULL Z) NIL)
(T
(PROG2 (COND ((ATOM (EVAL (CAR Z))) NIL)
((GREATERP Y (CDR (EVAL (CAR Z)))) NIL)
(T (SET (CAR Z) (CONS (CAR (EVAL (CAR Z))) (ADD1 (CDR (EVAL (CAR Z))))))))
(MOVE (CDR Z) Y)))))
EXPR)
(DEFPROP YMINAX
(LAMBDA(Z)
(COND ((NULL Z) NIL)
(T
(PROG (Y)
(SETQ Y (CDR (EVAL (CAR Z))))
(COND ((GREATERP Y YMAX) (SETQ YMAX Y)))
(COND ((LESSP Y YMIN) (SETQ YMIN Y)))
(YMINAX (CDR Z))))))
EXPR)
(DEFPROP YMISS
(LAMBDA(Z)
(COND ((NULL Z) NIL) ((NUMBERP (EVAL (CAR Z))) (CONS (CAR Z) (YMISS (CDR Z)))) (T (YMISS (CDR Z)))))
EXPR)
(DEFPROP LSP
(LAMBDA(Z)
(COND ((ATOM (CAR Z))
(PROG (TEM Y TPEN)
(SETQ TEM ORG)
(SETQ Y (COND ((SETQ TPEN (ATOM (CDR Z))) (CDR Z)) (T (CADR Z))))
(SETQ ORG (CONS (PLUS (TIMES SIZ (CAR Z)) (CAR ORG)) (PLUS (TIMES SIZ Y) (CDR ORG))))
(OUTC T NIL)
(COND ((NOT (EQ PEN TPEN)) (COND ((SETQ PEN TPEN) (DIT 17 20)) (T (DIT 20 40)))))
(MIDIT (TIMES SIZ (CAR Z)) (TIMES SIZ Y))
(OUTC NIL NIL)
(RETURN ORG)))
(T (PROG2 (LSP (LIST (CAAR Z) (CDAR Z))) (LSP (CDR Z))))))
EXPR)
(DEFPROP MIDIT
(LAMBDA(X Y)
(COND ((ZEROP X) (DIT (ABS Y) (COND ((MINUSP Y) 10) (T 4))))
((ZEROP Y) (DIT (ABS X) (COND ((MINUSP X) 2) (T 1))))
((EQ (ABS X) (ABS Y))
(DIT (ABS X) (PLUS 100 (COND ((MINUSP X) 2) (T 1)) (COND ((MINUSP Y) 10) (T 4)))))
(T
(PROG2 (MIDIT (QUOTIENT X 2) (QUOTIENT Y 2))
(MIDIT (DIFFERENCE X (QUOTIENT X 2)) (DIFFERENCE Y (QUOTIENT Y 2)))))))
EXPR)
(DEFPROP DIT
(LAMBDA (N X) (PROG NIL L (COND ((ZEROP N) (RETURN NIL))) (TYO X) (SETQ N (SUB1 N)) (GO L)))
EXPR)
(DEFPROP SOF
(LAMBDA NIL (PROG2 (OUTPUT PTP:) (OUTC T T) (LINELENGTH 377777) (OUTC NIL NIL)))
EXPR)
(DEFPROP EOF
(LAMBDA NIL (OUTC NIL T))
EXPR)
(DEFPROP POT
(LAMBDA(Z)
(COND ((NULL Z) (PROG2 (OUTC T NIL) (DIT 100 100) (EOF) NIL)) (T (PROG2 (LSP (CAR Z)) (POT (CDR Z))))))
EXPR)
(DEFPROP YMAX
(NIL . 0)
VALUE)
(DEFPROP XMAX
(NIL . 3)
VALUE)
(DEFPROP YMIN
(NIL . -1)
VALUE)
(DEFPROP F1
(NIL ((P1 P2 P3) P4 P5 P6) ((P7 P8 P9) P10 P11 P12))
VALUE)
(DEFPROP F2
(NIL ((P1 P4) K1 K2 P2) ((K1 P3) P4 P5) ((K2 P2) P3 P6))
VALUE)
(DEFPROP NK
(NIL (0 . 12) (10 0) (-10 . -5) (10 . -5) (2 0))
VALUE)
(DEFPROP NP
(NIL (0 . 12) (6 . 0) (2 . -2) (0 . -1) (-2 . -2) (-6 . 0) (12 -5))
VALUE)
(DEFPROP NODE
(NIL (2 4) (2 . -2) (0 . -4) (-2 . -2) (-4 . 0) (-2 . 2) (0 . 4) (2 . 2) (4 . 0) (-2 -4))
VALUE)
(DEFPROP N0
(NIL (3 0) (2 . 0) (3 . 3) (0 . 4) (-3 . 3) (-2 . 0) (-3 . -3) (0 . -4) (3 . -3) (7 0))
VALUE)
(DEFPROP N1
(NIL (1 7) (3 . 3) (0 . -12) (-3 0) (6 . 0) (3 0))
VALUE)
(DEFPROP N2
(NIL (0 10) (2 . 2) (3 . 0) (3 . -3) (0 . -2) (-1 . -1) (-5 . 0) (-2 . -2) (0 . -2) (10 . 0) (2 0))
VALUE)
(DEFPROP N3
(NIL (6 . 0) (2 . 2) (0 . 2) (-1 . 1) (-3 . 0) (3 0) (1 . 1) (0 . 2) (-2 . 2) (-6 . 0) (12 -12))
VALUE)
(DEFPROP N4
(NIL (4 12) (-4 . -6) (10 . 0) (-2 6) (0 . -12) (4 0))
VALUE)
(DEFPROP N5
(NIL (6 . 0) (2 . 2) (0 . 2) (-2 . 2) (-6 . 0) (0 . 4) (10 . 0) (2 -12))
VALUE)
(DEFPROP N6
(NIL (0 4) (2 . 2) (4 . 0) (2 . -2) (0 . -2) (-2 . -2) (-4 . 0) (-2 . 2) (0 . 5) (3 . 3) (5 . 0) (2 -12))
VALUE)
(DEFPROP N7
(NIL (10 . 12) (-10 . 0) (0 . -2) (12 -10))
VALUE)
(DEFPROP N8
(NIL (1 5)
(-1 . 1)
(0 . 2)
(2 . 2)
(4 . 0)
(2 . -2)
(0 . -2)
(-1 . -1)
(-6 . 0)
(-1 . -1)
(0 . -2)
(2 . -2)
(4 . 0)
(2 . 2)
(0 . 2)
(-1 . 1)
(3 -5))
VALUE)
(DEFPROP N9
(NIL (5 . 0) (3 . 3) (0 . 5) (-2 . 2) (-4 . 0) (-2 . -2) (0 . -2) (2 . -2) (4 . 0) (2 . 2) (2 -6))
VALUE)
(DEFPROP VADD
(LAMBDA (P1 P2) (CONS (PLUS (CAR P1) (CAR P2)) (PLUS (CDR P2) (CDR P1))))
EXPR)
(DEFPROP VSUB
(LAMBDA (P2 P3) (CONS (DIFFERENCE (CAR P2) (CAR P3)) (DIFFERENCE (CDR P2) (CDR P3))))
EXPR)
(DEFPROP VSUBSIZ
(LAMBDA (A B) (CONS (QUOTIENT (DIFFERENCE (CAR A) (CAR B)) SIZ) (QUOTIENT (DIFFERENCE (CDR A) (CDR B)) SIZ)))
EXPR)
(DEFPROP LXY
(LAMBDA (Z) (CONS (CAR Z) (NCONS (CDR Z))))
EXPR)
(DEFPROP SLOPE
(LAMBDA (P1 P2) (QUOTIENT (DIFFERENCE (CDR P2) (CDR P1) P 0.0) (DIFFERENCE (CAR P2) (CAR P1))))
EXPR)
(DEFPROP MIDPOINT
(LAMBDA (Z1 Z2) (CONS (QUOTIENT (PLUS (CAR Z1) (CAR Z2)) 2) (QUOTIENT (PLUS (CDR Z1) (CDR Z2)) 2)))
EXPR)
(DEFPROP METRIC
(LAMBDA (P1 P2) (PLUS (SQUARE (DIFFERENCE (CAR P1) (CAR P2))) (SQUARE (DIFFERENCE (CDR P1) (CDR P2)))))
EXPR)
(DEFPROP SQUARE
(LAMBDA (N) (TIMES N N))
EXPR)
(DEFPROP INCREM
(LAMBDA(P D)
(PROG (TEM)
(RETURN
(CONS (SETQ TEM (PLUS (CAR P) (ALSH (CDR P) (MINUS D)))) (DIFFERENCE (CDR P) (ALSH TEM (MINUS D)))))))
EXPR)
(DEFPROP CARLAST
(LAMBDA (Z) (CAR (LAST Z)))
EXPR)
(DEFPROP ALSH
(LAMBDA (Z N) (COND ((MINUSP Z) (MINUS (LSH (ABS Z) N))) (T (LSH Z N))))
EXPR)
(DEFPROP ADJUST
(LAMBDA (Z) (SET Z (CONS (TIMES (CAR (EVAL Z)) 300) (TIMES (CDR (EVAL Z)) 300))))
EXPR)
(DEFPROP ROTATE
(LAMBDA(P SIN COS)
(CONS (FIX (DIFFERENCE (TIMES COS (PLUS 0.0 (CAR P))) (TIMES SIN (PLUS 0.0 (CDR P)))))
(FIX (PLUS (TIMES COS (PLUS 0.0 (CDR P))) (TIMES SIN (PLUS 0.0 (CAR P)))))))
EXPR)
(DEFPROP ROOT
(LAMBDA (A) (NEWTON 14 (PLUS A 0.0) (QUOTIENT (PLUS A 0.0) 2.0)))
EXPR)
(DEFPROP NEWTON
(LAMBDA (N A X) (COND ((ZEROP N) X) (T (NEWTON (SUB1 N) A (QUOTIENT (PLUS X (QUOTIENT A X)) 2.0)))))
EXPR)
(DEFPROP ZIGZAG
(LAMBDA(N)
(PROG (P11)
(COND ((EQ PHASE 3) (SETQ PHASE 0)) (T (SETQ PHASE (ADD1 PHASE))))
(SETQ L2 (PLUS L2 3))
(SETQ P11 (ROTATE (CONS L2 N) SIN COS))
(LS (VSUB P11 P1))
(SETQ P1 P11)
(RETURN (GREATERP L2 L))))
EXPR)
(DEFPROP SQUIG
(LAMBDA(P1 P2 LS)
(PROG (L L2 SIN COS)
(SETQ P2 (VSUB P2 P1))
(SETQ P1 ACTEND)
(SETQ L2 (METRIC P1 P2))
(SETQ L (ROOT L2))
(SETQ SIN (QUOTIENT (CDR P2) L))
(SETQ COS (QUOTIENT (CAR P2) L))
(SETQ L2 0)
(SETQ L (FIX (DIFFERENCE L 3)))
(COND ((GREATERP L2 L) (GO EXIT))
((ZEROP PHASE) (GO LOOP))
((EQ PHASE 1) (GO PH1))
((EQ PHASE 2) (GO PH2))
(T (GO PH3)))
LOOP (COND ((ZIGZAG 10) (GO EXIT)))
PH1 (COND ((ZIGZAG 0) (GO EXIT)))
PH2 (COND ((ZIGZAG -10) (GO EXIT)))
PH3 (COND ((ZIGZAG 0) (GO EXIT)) (T (GO LOOP)))
EXIT (SETQ ACTEND (VSUB P1 P2))
(RETURN NIL)))
EXPR)
(DEFPROP TESTS
(NIL TP1 TP2 TP3 TP4 TP5 TP6 TP7 TP8 TP9 TP10 TP11 TP12 TP13 TP14 TP15 TP16 TP17 TP18 TP19 TP20 TP20 TP22)
VALUE)
(DEFPROP TP1
(NIL ((P2) P1 K1) ((P4) P3 K2) ((P6 K2 K1) P5))
VALUE)
(DEFPROP TP2
(NIL ((P2) P1 K1) ((P4 K1) P3 K2) ((P6 K2) P5))
VALUE)
(DEFPROP TP3
(NIL ((K2) P2 P1) ((P4) P3 K1) ((K1 P1) P5))
VALUE)
(DEFPROP TP4
(NIL ((K2) P2 P1) ((P4) P3 K1) ((P5 K1 P1)))
VALUE)
(DEFPROP TP5
(NIL ((K2) P2 P1) ((P1) P3 K1) ((P5 K1) P4))
VALUE)
(DEFPROP TP6
(NIL ((K2) P2 P1) ((P3 P1) K1) ((P5 K1) P4))
VALUE)
(DEFPROP TP7
(NIL ((K2 P2) P1) ((P4) P3 K1) ((P5 K1 P1)))
VALUE)
(DEFPROP TP8
(NIL ((K2 P2) P1) ((P3 P1) K1) ((P5 K1) P4))
VALUE)
(DEFPROP TP9
(NIL ((P3) P2 K1) (NIL P4 K2 P1) ((K2 P1 K1) P5))
VALUE)
(DEFPROP TP10
(NIL ((P3) P2 K1) ((K1) P4 K2 P1) ((K2 P1) P5))
VALUE)
(DEFPROP TP11
(NIL ((K2) P3 P1) (NIL P4 K1 P2) ((K1 P2 P1) P5))
VALUE)
(DEFPROP TP12
(NIL ((K2) P3 P1) (NIL P4 K1 P2) ((K1 P2 P1)))
VALUE)
(DEFPROP TP13
(NIL ((K2) P3 P1) ((P1) P4 K1 P2) ((K1 P2) P5))
VALUE)
(DEFPROP TP14
(NIL ((K2) P3 P1) ((P1) K1 P2) ((K1 P2) P4))
VALUE)
(DEFPROP TP15
(NIL ((K2 P3) P1) (NIL P4 K1 P2) ((K1 P2 P1)))
VALUE)
(DEFPROP TP16
(NIL ((K2 P3) P1) ((P1) K1 P2) ((K1 P2) P4))
VALUE)
(DEFPROP TP17
(NIL ((P4) P3 K1) (NIL P5 K2 P2 P1) ((K2 P2 P1 K1)))
VALUE)
(DEFPROP TP18
(NIL ((P4) P3 K1) ((K1) P5 K2 P2 P1) ((K2 P2 P1)))
VALUE)
(DEFPROP TP19
(NIL ((K2) P4 P1) (NIL P5 K1 P3 P2) ((K1 P3 P2 P1)))
VALUE)
(DEFPROP TP20
(NIL ((K2) P4 P1) (NIL P5 K1 P3 P2) ((K1 P3 P2 P1)))
VALUE)
(DEFPROP TP20
(NIL ((K2) P4 P1) (NIL P5 K1 P3 P2) ((K1 P3 P2 P1)))
VALUE)
(DEFPROP TP22
(NIL ((K2 P4) P1) (NIL P5 K1 P3 P2) ((K1 P3 P2 P1)))
VALUE)
(DEFPROP OFF
(LAMBDA NIL (OUTC NIL T))
EXPR)